perm filename FILLN.NL2[XX,LCS] blob
sn#231772 filedate 1976-08-15 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SUBROUTINE FILLER(QQ,MD)
C00005 ENDMK
Cā;
SUBROUTINE FILLER(QQ,MD)
COMMON /RINP/I(900)
DIMENSION H(350),Q(600)
EQUIVALENCE (Q,I)
KNT=I(3)
RL=Q(1)
RR=RL
DO 1 K=1,KNT,3
CC Q(K)=IFIX(Q(K))
CC Q(K+1)=IFIX(Q(K+1))
A=Q(K)
IF(RL.GT.A)RL=A
1 IF(RR.LT.A)RR=A
C GET LEFT AND RIGHT EXTREME LIMITS.
RR=RR-.5
RL=RL-.5
2 RL=RL+1
C SLICE COUNTER
M=0
DO 3 J=4,KNT,3
IF(I(J+2).EQ.3)GO TO 3
IF(HORZ(I,J,RL))GO TO 3
C FINDS SEGS UNDER SLICE AND REJECTS VERTICALS.
M=M+1
H(M)=HGT(J,RL,I)
3 CONTINUE
5 NN=0
DO 4 J=1,M-1
IF(H(J).GE.H(J+1))GO TO 4
C SORT HEIGHTS
CALL EXCH(H(J),H(J+1))
NN=-1
4 CONTINUE
IF(NN)GO TO 5
C GO BACK IF MORE SORTING TO BE DONE
NN=1
6 IF(H(NN).EQ.H(NN+1))GO TO 7
A=H(NN)
B=H(NN+1)
CALL LINX(RL,A,RL,B)
7 NN=NN+2
C SKIP BY 2'S
IF(NN.LT.M)GO TO 6
IF(RL.LT.RR)GO TO 2
END
FUNCTION HGT(J,RL,Q)
DIMENSION Q(1)
HT=Q(J-2)
C PREVIOUS Y COORD.
A=Q(J-3)
C PREVIOUS X COORD.
B=Q(J+1)-HT
C=RL-A
D=Q(J)-A
CC HGT=((I(J+1)-HGT)*(L-K))/(I(J)-K)+HGT
1 HGT=(B*C)/D+HT
CAN HAVE A DIVIDE BY ZERO HERE!!
END
FUNCTION HORZ(Q,J,RL)
C L=VERT. SLICE
DIMENSION Q(1)
HORZ=0
A=Q(J)
B=Q(J-3)
C PREVIOUS X COORD.
IF(A.EQ.B)GO TO 1
IF(A.GT.B)CALL EXCH(A,B)
IF(RL.LE.B.AND.RL.GE.A)RETURN
1 HORZ=-1
END